Fritz: All Fritz/All Fritz.zip/All Fritz/FILES/ARTIENCE/INFER.LZH/INFER.PAS

Pascal/Delphi Source File | 1988-10-24 | 8KB | 357 lines

Program Infer;

{
  Norman Newman, Kibbutz Mishmar David.
  OMSI Pascal-2 version  - 14 Dec 1986
  Turbo Pascal-3 version - 21 Mar 1988
  Updated to TP 4 - October 1988. No changes needed.

  This program solves the hypothetical syllogism. For more help,
  see the file 'infer.txt'.

  Permission is granted to use this program, or portions thereof,
  for non-commercial purposes. All other rights are reserved to
  the original author.

}

type
 string50 = string[50];

 pointer = ^pointer_type;
 pointer_type = record
                 name: string50;
                 head: set of 0..255;
                 next: pointer
                end;

var
 class_front, class_rear, data_front, data_rear: pointer;
 in_line: string50;
 i, class_count: integer;

{ ------------------------------------------------------- }
{                 Low level procedures                    }
{ ------------------------------------------------------- }

 procedure strip_article (var s: string50);
  var
   i: integer;

  begin
   i:= 0;
   if pos ('a',s) = 1 then i:= 3
   else if pos ('an', s) = 1 then i:= 4
   else if pos ('the', s) = 1 then i:= 5;
   if i > 0 then s:= copy (s, i, length(s) + 1 - i)
  end;

 procedure parse (var main, left, right: string50;
                  place, count: integer);
  { This procedure accepts as input the string 'main', puts the
    first place - 1 characters into the string 'left', and puts
    the rest (less count) into 'right'. All leading articles are
    stripped from the substrings.
  }

  begin
   left:= copy (main, 1, place - 1);
   strip_article (left);
   place:= place + count;
   count:= length (main) - place;
   right:= copy (main, place + 1, count);
   strip_article (right)
  end;

 function find_match (list: pointer;
                      var s: string50): integer;
  var
   found: boolean;
   i: integer;

  begin
   found:= false;
   i:= 0;
   while list <> nil do
    begin
     i:= i + 1;
     if list^.name = s
      then
       begin
        found:= true;
        list:= nil
       end
      else list:= list^.next
    end;

   if found
    then find_match:= i
    else find_match:= 0
  end;

 function get_list (list: pointer; n: integer): pointer;
  { Return the n'th member of 'list' }
  var
   i: integer;

  begin
   for i:= 1 to n - 1 do list:= list^.next;
   get_list:= list
  end;

{ ------------------------------------------------------- }
{                 High level procedures                   }
{ ------------------------------------------------------- }

 procedure declare (place: integer);
  var
   subject, object: string50;
   p: pointer;
   count: integer;

  begin
   parse (in_line, subject, object, place, 3);
   { 'is ' occupies 3 places }
   place:= find_match (class_front, subject);

   { insert the subject if need be }
   if place = 0
    then
     begin
      class_count:= class_count + 1;
      place:= class_count;
      new (p);
      with p^ do
       begin
        name:= subject;
        head:= [];
        next:= nil
       end;

      if class_front = nil
       then class_front:= p
       else class_rear^.next:= p;
      class_rear:= p
     end;

   { insert the object }
   count:= find_match (data_front, object);
   if count = 0             { new object }
    then
     begin
      new (p);
      with p^ do
       begin
        name:= object;
        head:= [place];
        next:= nil
       end;

      if data_front = nil
       then data_front:= p
       else data_rear^.next:= p;
      data_rear:= p
     end
    else
     begin
      p:= get_list (data_front, count);
      p^.head:= p^.head + [place]
     end;

   writeln ('Noted')
  end { declare };

 procedure inquire;
  var
   subject, object: string50;
   place, count: integer;
   found: boolean;

  procedure backtrack (place, count: integer;
                       list: pointer;
                       var found: boolean);
   var
    i: integer;
    p, q: pointer;

   begin
    if count > 0
     then
      begin
       p:= get_list (list, count);
       i:= 0;
       repeat
        i:= i + 1;
        if i in p^.head
         then
          begin
           found:= place = i;
           if not found
            then
             begin
              q:= get_list (class_front, i);
              count:= find_match (data_front, q^.name);
              backtrack (place, count, list, found)
             end
          end
       until found or (i = class_count)
      end
   end { backtrack };

  begin { inquire }
   { get rid of opening 'is ' }
   in_line:= copy (in_line, 4, length(in_line) - 3);
   { if there is a question mark at the end, remove it }
   if in_line[length(in_line)] = '?'
    then in_line[0]:= pred(in_line[0]);

   { strip initial article - if present }
   strip_article (in_line);
   { look for article separating the clauses }
   place:= pos (' a ', in_line);
   if place <> 0 then count:= 2
   else
    begin
     place:= pos (' an ',in_line);
     if place <> 0 then count:= 3
     else
      begin
       place:= pos (' the ', in_line);
       if place <> 0 then count:= 4
      end
    end;

   if place = 0 then writeln ('I don''t understand')
   else
    begin
     parse (in_line, subject, object, place, count);
     place:= find_match (class_front, subject);
     if place = 0
      then
       begin
        write ('I have no data concerning ');
        writeln (subject)
       end
      else
       begin
        found:= false;
        count:= find_match (data_front, object);
        backtrack (place, count, data_front, found);
        if found
         then writeln ('Yes')
         else writeln ('I don''t know')
       end
    end
  end { inquire };

 procedure who_is (flag: boolean);
  var
   answers: set of 0..255;
   subject: string50;
   i: integer;
   p: pointer;

  procedure find_answers (place: integer);
   var
    p, q: pointer;
    i: integer;

   begin
    if place > 0
     then
      begin
       p:= get_list (data_front, place);
       for i:= 1 to class_count do
        if i in p^.head
         then
          begin
           q:= get_list (class_front, i);
           answers:= answers + [i];
           find_answers (find_match (data_front, q^.name))
          end
      end
   end { find_answers };

  begin { who is ? }
   answers:= [];
   { strip interrogative }
   if flag
    then i:= 7   { 'who is '}
    else i:= 8;  { 'what is '}
   in_line:= copy (in_line, i+1, length(in_line) - i);
   { strip question mark, if present }
   if in_line[length(in_line)] = '?'
    then in_line[0]:= pred(in_line[0]);
   subject:= in_line;
   strip_article (subject);
   find_answers (find_match(data_front, subject));

   if answers = []
    then if flag
     then writeln ('No one.')
     else writeln ('Nothing.')
    else for i:= 1 to class_count do
     if i in answers
      then
       begin
        p:= get_list (class_front, i);
        writeln (p^.name, ' is ', in_line);
       end
  end { who is? };

 procedure requests;
  var
   place: integer;

  procedure print (list: pointer; place: integer);
   begin
    while list <> nil do
     with list^ do
      begin
       if place in head then writeln (name);
       list:= next
      end
   end;

  begin { requests }
   { get rid of opening 'request' }
   in_line:= copy (in_line, 9, length(in_line) - 8);
   place:= find_match (class_front, in_line);
   if place = 0
    then writeln ('I have no data comncerning ', in_line)
    else
     begin
      writeln (in_line, ' is ...');
      print (data_front, place)
     end
  end { request };

begin { infer }
 class_front:= nil;
 data_front:= nil;
 class_count:= 0;

 write ('-> ');
 readln (in_line);
 while (in_line <> 'bye') do
  begin
   if pos ('is ', in_line) = 1 then inquire
   else if pos ('request ', in_line) = 1 then requests
   else if pos ('who ', in_line) = 1 then who_is (true)
   else if pos ('what ', in_line) = 1 then who_is (false)
   else
    begin
     i:= pos (' is ', in_line);
     if i <> 0
      then declare (i)
      else writeln ('What???')
    end;

   writeln;
   write ('-> ');
   readln (in_line)
  end
end.